home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / clos_lf6.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  16.8 KB  |  698 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file clos_lf6.c */
  5.  
  6. #include "clos.h"
  7.  
  8. #define LONGJMP_LOOP    1
  9. #define LONGJMP_GO    2
  10. void internal_update_environment();
  11. void internal_setf();
  12. void general_lf_let();
  13. void general_lf_do();
  14.  
  15.  
  16. /* iteratori e modificatori di environment ************************************/
  17. /* RETURN , LOOP , PROG1 , PROGN , WHILE , LET , LET* , DO , DO* , PROG , GO  */
  18. /******************************************************************************/
  19.  
  20.  
  21. /************************************************************************/
  22. /*         Variabili che campionano lo stato dell' interprete           */
  23. /* all' ingresso di una funzione che ammette RETURN per uscire          */
  24. jmp_buf  loop_jmp;        /* indirizzo di ritorno + stack-pointer */
  25. int      loop_jmp_valid=FALSE;  /* l'indirizzo di ritorno è valido?     */
  26. /* NB: deve venire azzerato quando si ritorna al top-level perche'      */
  27. /*altrimenti una return salterebbe chissa'dove se e' chiamata  dopo     */
  28. /*un errore in un loop o in un do                     */
  29. unsigned loop_jmp_flags;    /* flags di valutazione            */
  30. node_p   loop_jmp_nout;        /* valore specificato nella RETURN    */
  31. /************************************************************************/
  32.  
  33. jmp_buf    go_jmp;
  34. int    go_jmp_valid=FALSE;
  35. node    go_jmp_label;
  36.  
  37.  
  38.  
  39.  
  40. void lf_return LF_PARAMS
  41. {
  42.  if(loop_jmp_valid){
  43.    if(IS_CONS(nin)){
  44.      eval(CONSLEFT(nin),&loop_jmp_nout,genv,lenv,loop_jmp_flags);
  45.      longjmp(loop_jmp,LONGJMP_LOOP);
  46.    }
  47.    loop_jmp_nout.node=NIL;
  48.    loop_jmp_nout.type=P_ALLNODE;
  49.    longjmp(loop_jmp,LONGJMP_LOOP);
  50.  }
  51.  error(E_BADRETURN,ERR_MERROR|ERR_TBLVL|ERR_PVOID,NULL);
  52. }
  53.  
  54. void lf_loop LF_PARAMS
  55. {
  56.  node k;
  57.  
  58.  node n=nin;
  59.  jmp_buf  save_jmp;
  60.  unsigned save_valid=loop_jmp_valid;
  61.  unsigned save_flags=loop_jmp_flags;
  62.  
  63.  loop_jmp_valid=TRUE;
  64.  loop_jmp_flags=fl;
  65.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  66.  
  67.  switch(setjmp(loop_jmp)){
  68.      case LONGJMP_LOOP:
  69.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  70.      loop_jmp_valid=save_valid;
  71.      loop_jmp_flags=save_flags;
  72.      nout->node=loop_jmp_nout.node;
  73.      nout->type=loop_jmp_nout.type;
  74.      return;
  75.  }
  76.  k=node_getlastlock();
  77.  for(;;){
  78.    if(IS_CONS(n)){
  79.      eval(CONSLEFT(n),nout,genv,lenv,EVAL_NORM);
  80.      n=CONSRIGHT(n);
  81.      continue;
  82.    }
  83.    n=nin;
  84.    node_signal(k);    /* con questa chiamata si dice al gc che può      */
  85.               /* distruggere tutti i nodi allocati dall' inizio */
  86.               /* del ciclo in poi */
  87.  }
  88. }
  89.  
  90. void lf_prog1 LF_PARAMS
  91. {
  92.  node_p ntrash;
  93.  jmp_buf  save_jmp;
  94.  unsigned save_valid=loop_jmp_valid;
  95.  unsigned save_flags=loop_jmp_flags;
  96.  
  97.  loop_jmp_valid=TRUE;
  98.  loop_jmp_flags=fl;
  99.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  100.  
  101.  switch(setjmp(loop_jmp)){
  102.      case LONGJMP_LOOP:
  103.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  104.      loop_jmp_valid=save_valid;
  105.      loop_jmp_flags=save_flags;
  106.      nout->node=loop_jmp_nout.node;
  107.      nout->type=loop_jmp_nout.type;
  108.      return;
  109.  }
  110.  if(IS_CONS(nin)){
  111.    eval(CONSLEFT(nin),nout,genv,lenv,fl);
  112.    while(IS_CONS(nin=CONSRIGHT(nin))){
  113.      eval(CONSLEFT(nin),&ntrash,genv,lenv,EVAL_NORM);
  114.    }
  115.    memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  116.    loop_jmp_valid=save_valid;
  117.    loop_jmp_flags=save_flags;
  118.    return;
  119.  }
  120.  
  121. }
  122.  
  123. void lf_progn LF_PARAMS
  124. {
  125.  jmp_buf  save_jmp;
  126.  unsigned save_valid=loop_jmp_valid;
  127.  unsigned save_flags=loop_jmp_flags;
  128.  
  129.  loop_jmp_valid=TRUE;
  130.  loop_jmp_flags=fl;
  131.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  132.  
  133.  switch(setjmp(loop_jmp)){
  134.      case LONGJMP_LOOP:
  135.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  136.      loop_jmp_valid=save_valid;
  137.      loop_jmp_flags=save_flags;
  138.      nout->node=loop_jmp_nout.node;
  139.      nout->type=loop_jmp_nout.type;
  140.      return;
  141.  }
  142.  while(IS_CONS(CONSRIGHT(nin))){
  143.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_NORM);
  144.      nin=CONSRIGHT(nin);
  145.  }
  146.  eval(CONSLEFT(nin),nout,genv,lenv,fl);
  147.  memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  148.  loop_jmp_valid=save_valid;
  149.  loop_jmp_flags=save_flags;
  150. }
  151.  
  152. void lf_while LF_PARAMS
  153. {
  154.  /* sintassi (while (test ret?) sx*) */
  155.  /* valuta le sx finchè test è non-NIL,ritorna ret (se non c'è ritorna NIL)*/
  156.  
  157.  node test;
  158.  node ret;
  159.  node sx;
  160.  node k;
  161.  node n=nin;
  162.  
  163.  /* nin= ((test ret?) sx*) */
  164.  if(IS_CONS(nin)){
  165.    nin=CONSLEFT(nin);    /* nin=(test ret?) */
  166.    if(IS_CONS(nin)){
  167.      test=CONSLEFT(nin);
  168.      nin=CONSRIGHT(nin); /* nin=(ret?) */
  169.      if(IS_CONS(nin)){
  170.        ret=CONSLEFT(nin);
  171.      }else{
  172.        ret=NIL;
  173.      }
  174.      k=node_getlastlock();
  175.      for(;;){
  176.        eval(test,nout,genv,lenv,EVAL_NORM);
  177.        if(calc_pointer(nout)==NIL)break;
  178.        sx=CONSRIGHT(n);
  179.        while(IS_CONS(sx)){
  180.      eval(CONSLEFT(sx),nout,genv,lenv,EVAL_NORM);
  181.      sx=CONSRIGHT(sx); /* sx=(sx*) , n= ((test ret?) sx*) */
  182.        }
  183.        node_signal(k);
  184.      }
  185.      eval(ret,nout,genv,lenv,fl);
  186.      return;
  187.    }
  188.  }
  189.  error(E_FEWARGS,ERR_MERROR|ERR_PNODE|ERR_TBLVL,&n);
  190. }
  191.  
  192.  
  193. void lf_dolist LF_PARAMS
  194. {
  195.  /* syntax (dolist  (counter intiform  sx?  )   sx*    )   */
  196.  /*                                   zero    nonzero      */
  197.  
  198.  node zero_sx;
  199.  node nonzero_sx;
  200.  node name;
  201.  node value;
  202.  node l,k;
  203.  node new_lenv=lenv;
  204.  node new_genv=genv;
  205.  
  206.  jmp_buf  save_jmp;
  207.  unsigned save_valid=loop_jmp_valid;
  208.  unsigned save_flags=loop_jmp_flags;
  209.  
  210.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  211.  loop_jmp_valid=TRUE;
  212.  loop_jmp_flags=fl;
  213.  switch(setjmp(loop_jmp)){
  214.      case LONGJMP_LOOP:
  215.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  216.      loop_jmp_valid=save_valid;
  217.          loop_jmp_flags=save_flags;
  218.      nout->node=loop_jmp_nout.node;
  219.      nout->type=loop_jmp_nout.type;
  220.      return;
  221.  }
  222.  k=node_getlastlock();
  223.  
  224.  /* nin= ( (counter-name initform   sx*   ) {sx}* ) */
  225.  /*                                 zero   nonzero  */
  226.  
  227.  if(IS_CONS(nin)){
  228.    if(IS_CONS(l=CONSLEFT(nin))){ /* l=(counter initform sx*) */
  229.      name=CONSLEFT(l);
  230.      if(IS_NAME(name)&&HAS_NAME(name)){
  231.        if(IS_CONS(l=CONSRIGHT(l))){           /* l=(initform sx*)  */
  232.      eval(CONSLEFT(l),nout,genv,lenv,EVAL_NORM);
  233.      value=calc_pointer(nout);
  234.      if(IS_CONS(value) || value==NIL){
  235.        if(IS_CONS(l=CONSRIGHT(l))){ /* l=(sx*) */
  236.          zero_sx=CONSLEFT(l);
  237.        }else{
  238.          zero_sx=NIL;
  239.        }
  240.        internal_update_environment(name,NIL,&new_genv,&new_lenv);
  241.        k=node_getlastlock();
  242.        while(IS_CONS(value)){
  243.          internal_setf(name,CONSLEFT(value),new_genv,new_lenv);
  244.          nonzero_sx=CONSRIGHT(nin);
  245.          while(IS_CONS(nonzero_sx)){
  246.            eval(CONSLEFT(nonzero_sx),nout,new_genv,new_lenv,EVAL_NORM);
  247.            nonzero_sx=CONSRIGHT(nonzero_sx);
  248.          }
  249.          value=CONSRIGHT(value);
  250.          node_signal(k);
  251.        }
  252.        internal_setf(name,value,new_genv,new_lenv);
  253.        eval(zero_sx,nout,new_genv,new_lenv,fl);
  254.  
  255.        loop_jmp_valid=save_valid;
  256.        loop_jmp_flags=save_flags;
  257.        memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  258.        return;
  259.      }
  260.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&value);
  261.        }
  262.        error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&CONSLEFT(nin));
  263.      }
  264.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&name);
  265.    }
  266.    error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  267.  }
  268.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  269. }
  270.  
  271.  
  272. void lf_dotimes LF_PARAMS
  273. {
  274.  /* syntax (dotimes (counter intiform  sx?  )   sx*    )   */
  275.  /*                                   zero    nonzero      */
  276.  /* Conta da 0 a initform-1 */
  277.  
  278.  node zero_sx;
  279.  node nonzero_sx;
  280.  node name;
  281.  node value;
  282.  node l,k;
  283.  node new_genv=genv;
  284.  node new_lenv=lenv;
  285.  n_int limit;
  286.  
  287.  jmp_buf  save_jmp;
  288.  unsigned save_valid=loop_jmp_valid;
  289.  unsigned save_flags=loop_jmp_flags;
  290.  
  291.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  292.  loop_jmp_valid=TRUE;
  293.  loop_jmp_flags=fl;
  294.  switch(setjmp(loop_jmp)){
  295.      case LONGJMP_LOOP:
  296.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  297.      loop_jmp_valid=save_valid;
  298.      loop_jmp_flags=save_flags;
  299.      nout->node=loop_jmp_nout.node;
  300.      nout->type=loop_jmp_nout.type;
  301.      return;
  302.  }
  303.  
  304.  /* nin= ( (counter-name initform   sx*   ) {sx}* ) */
  305.  /*                                 zero   nonzero  */
  306.  
  307.  if(IS_CONS(nin)){
  308.    if(IS_CONS(l=CONSLEFT(nin))){ /* l=(counter initform sx*) */
  309.      name=CONSLEFT(l);
  310.      if(IS_NAME(name)&&HAS_NAME(name)){
  311.        if(IS_CONS(l=CONSRIGHT(l))){           /* l=(initform sx*)  */
  312.      eval(CONSLEFT(l),nout,genv,lenv,EVAL_NORM);
  313.      value=calc_pointer(nout);
  314.      if(IS_VALUE(value) && GET_VTYPE(value)==NT_INTEGER && INTEGER(value)>=0){
  315.        limit=INTEGER(value);
  316.        value=node_make();
  317.        TYPE(value)|=NT_IS_VALUE+NT_INTEGER;
  318.        INTEGER(value)=0;
  319.        if(IS_CONS(l=CONSRIGHT(l))){ /* l=(sx*) */
  320.          zero_sx=CONSLEFT(l);
  321.        }else{
  322.          zero_sx=NIL;
  323.        }
  324.        internal_update_environment(name,value,&new_genv,&new_lenv);
  325.  
  326.        k=node_getlastlock();
  327.        while(INTEGER(value)!=limit){
  328.          nonzero_sx=CONSRIGHT(nin);
  329.          while(IS_CONS(nonzero_sx)){
  330.            eval(CONSLEFT(nonzero_sx),nout,new_genv,new_lenv,EVAL_NORM);
  331.            nonzero_sx=CONSRIGHT(nonzero_sx);
  332.          }
  333.          INTEGER(value)++;
  334.          internal_setf(name,value,new_genv,new_lenv);
  335.          /* perche' si potrebbe modificare il valore di 'name' */
  336.          /* nelle espressioni valutate */
  337.          node_signal(k);
  338.        }
  339.        eval(zero_sx,nout,new_genv,new_lenv,fl);
  340.  
  341.        loop_jmp_valid=save_valid;
  342.        loop_jmp_flags=save_flags;
  343.        memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  344.        return;
  345.      }
  346.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&value);
  347.        }
  348.        error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&CONSLEFT(nin));
  349.      }
  350.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&name);
  351.    }
  352.    error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  353.  }
  354.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  355. }
  356.  
  357.  
  358.  
  359.  
  360. #define LET_NORMAL  1
  361. #define LET_SPECIAL 0
  362.  
  363. void lf_let LF_PARAMS
  364. {
  365.  general_lf_let(nin,nout,genv,lenv,fl,LET_NORMAL);
  366. }
  367.  
  368. void lf_letspecial LF_PARAMS
  369. {
  370.  general_lf_let(nin,nout,genv,lenv,fl,LET_SPECIAL);
  371. }
  372.  
  373. void general_lf_let (nin,nout,genv,lenv,fl,let_flag)
  374. node nin;
  375. node_p *nout;
  376. node genv;
  377. node lenv;
  378. unsigned fl;
  379. unsigned let_flag;
  380. {
  381.  /* sintassi (LET [ ( {(p v) | p}* ) ] sx+  ) */
  382.  /* NB: se si ha (LET () sx+) l'atomo () cioe' NIL viene valutato */
  383.  /* come una s-espressione ma cio' non causa problemi */
  384.  
  385.  node new_genv=genv;
  386.  node new_lenv=lenv;
  387.  node parl,name,value;
  388.  
  389.  if(IS_CONS(nin)){
  390.    if(IS_CONS(parl=CONSLEFT(nin))){
  391.      if(IS_CONS(CONSRIGHT(nin))){
  392.        nin=CONSRIGHT(nin);
  393.        while(IS_CONS(parl)){
  394.      value=CONSLEFT(parl);
  395.      if(IS_CONS(value)){
  396.        name=CONSLEFT(value);
  397.        value=CONSRIGHT(value);
  398.        if(IS_CONS(value)){
  399.          value=CONSLEFT(value);
  400.        }
  401.        if(let_flag)
  402.          eval(value,nout,genv,lenv,EVAL_NORM);
  403.        else{
  404.          eval(value,nout,new_genv,new_lenv,EVAL_NORM);
  405.        }
  406.        value=calc_pointer(nout);
  407.      }else{
  408.        name=value;
  409.        value=NIL;
  410.      }
  411.      if(IS_NAME(name)&&HAS_NAME(name))
  412.        internal_update_environment(name,value,&new_genv,&new_lenv);
  413.      else
  414.        error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&name);
  415.      parl=CONSRIGHT(parl);
  416.        }
  417.      }else{
  418.        error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  419.      }
  420.    }
  421.    /* nin e' sicuramente un cons */
  422.    while(IS_CONS(CONSRIGHT(nin))){
  423.      eval(CONSLEFT(nin),nout,new_genv,new_lenv,EVAL_NORM);
  424.      nin=CONSRIGHT(nin);
  425.    }
  426.    eval(CONSLEFT(nin),nout,new_genv,new_lenv,fl);
  427.    return;
  428.  }
  429.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  430. }
  431.  
  432.  
  433.  
  434. #define DO_NORMAL  1
  435. #define DO_SPECIAL 0
  436.  
  437. void lf_do LF_PARAMS
  438. {
  439.  general_lf_do(nin,nout,genv,lenv,fl,DO_NORMAL);
  440. }
  441.  
  442. void lf_dospecial LF_PARAMS
  443. {
  444.  general_lf_do(nin,nout,genv,lenv,fl,DO_SPECIAL);
  445. }
  446.  
  447. void general_lf_do(nin,nout,genv,lenv,fl,do_flag)
  448. node nin;
  449. node_p *nout;
  450. node genv;
  451. node lenv;
  452. unsigned fl;
  453. unsigned do_flag;
  454. {
  455.  node name,value;
  456.  node new_lenv,new_genv;
  457.  node parlist,parl;
  458.  node curr,test;
  459.  node zero_sx,nonzero_sx;
  460.  node k;
  461.  
  462.  jmp_buf  save_jmp;
  463.  unsigned save_valid=loop_jmp_valid;
  464.  unsigned save_flags=loop_jmp_flags;
  465.  
  466.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  467.  loop_jmp_valid=TRUE;
  468.  loop_jmp_flags=fl;
  469.  switch(setjmp(loop_jmp)){
  470.      case LONGJMP_LOOP:
  471.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  472.      loop_jmp_valid=save_valid;
  473.      loop_jmp_flags=save_flags;
  474.      nout->node=loop_jmp_nout.node;
  475.      nout->type=loop_jmp_nout.type;
  476.      return;
  477.  }
  478.  
  479.  new_lenv=lenv;
  480.  new_genv=genv;
  481.  
  482.  /* sintassi (do ( (varname initvalue step)* ) (endtest sx*) sx*) */
  483.  if(IS_CONS(nin)){
  484.    parlist=parl=CONSLEFT(nin);
  485.    if(IS_CONS(nin=CONSRIGHT(nin))){   /*nin=( (endtest sx*) sx*)*/
  486.      if(IS_CONS(test=CONSLEFT(nin))){
  487.        nonzero_sx=CONSRIGHT(nin);
  488.        zero_sx=CONSRIGHT(test);
  489.        test=CONSLEFT(test);
  490.        /* creazione dell' environment */
  491.        while(IS_CONS(parl)){
  492.      if(IS_CONS(curr=CONSLEFT(parl))){
  493.        name=CONSLEFT(curr);
  494.        if(IS_CONS(curr=CONSRIGHT(curr))){
  495.          if(do_flag==DO_NORMAL)
  496.            eval(CONSLEFT(curr),nout,genv,lenv,EVAL_NORM);
  497.          else{
  498.            eval(CONSLEFT(curr),nout,new_genv,new_lenv,EVAL_NORM);
  499.          }
  500.          value=calc_pointer(nout);
  501.          if(IS_CONS(CONSRIGHT(curr))){
  502.            if(IS_NAME(name)&&HAS_NAME(name)){
  503.          internal_update_environment(name,value,&new_genv,&new_lenv);
  504.          parl=CONSRIGHT(parl);
  505.          continue;
  506.            }
  507.            error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&name);
  508.          }
  509.        }
  510.      }
  511.      error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&curr);
  512.        }
  513.  
  514.        k=node_getlastlock();
  515.        /* main-loop */
  516.        for(;;){
  517.      lenv=new_lenv;
  518.      genv=new_genv;
  519.  
  520.      node_lock(new_genv);
  521.      node_lock(new_lenv);
  522.  
  523.      eval(test,nout,genv,lenv,EVAL_NORM);
  524.      if(calc_pointer(nout)!=NIL)
  525.        break;
  526.      curr=nonzero_sx;
  527.      while(IS_CONS(curr)){
  528.        eval(CONSLEFT(curr),nout,genv,lenv,EVAL_NORM);
  529.        curr=CONSRIGHT(curr);
  530.      }
  531.      /* update-environment */
  532.      parl=parlist;
  533.      while(IS_CONS(parl)){
  534.        if(do_flag==DO_NORMAL){
  535.          eval
  536.         ( CONSLEFT(CONSRIGHT(CONSRIGHT(curr=CONSLEFT(parl))))
  537.         ,nout,genv,lenv,EVAL_NORM);
  538.        }else{
  539.          eval
  540.         ( CONSLEFT(CONSRIGHT(CONSRIGHT(curr=CONSLEFT(parl))))
  541.         ,nout,new_genv,new_lenv,EVAL_NORM);
  542.        }
  543.        internal_update_environment
  544.          (CONSLEFT(curr),calc_pointer(nout),&new_genv,&new_lenv);
  545.  
  546.        parl=CONSRIGHT(parl);
  547.      }
  548.      /* si dice al garbage collector che puo' distruggere tutti i nodi */
  549.      /* fin qui' allocati (tranne l'environment) */
  550.      node_signal(k);
  551.  
  552.        }
  553.        /* exit */
  554.        if(IS_CONS(zero_sx)){
  555.      while(IS_CONS(CONSRIGHT(zero_sx))){
  556.        eval(CONSLEFT(zero_sx),nout,new_genv,new_lenv,EVAL_NORM);
  557.        zero_sx=CONSRIGHT(zero_sx);
  558.      }
  559.      eval(CONSLEFT(zero_sx),nout,new_genv,new_lenv,fl);
  560.        }else{
  561.      nout->node=NIL;
  562.      nout->type=P_ALLNODE;
  563.        }
  564.        loop_jmp_valid=save_valid;
  565.        loop_jmp_flags=save_flags;
  566.        memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  567.        return;
  568.      }
  569.    }
  570.  }
  571.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  572. }
  573.  
  574.  
  575.  
  576.  
  577.  
  578.  
  579.  
  580.  
  581.  
  582. /* Sintassi (PROG ( (Nome Valore) ) s-espressioni ) */
  583.  
  584. void lf_prog LF_PARAMS
  585. {
  586.  node new_genv=genv;
  587.  node new_lenv=lenv;
  588.  node parl,name,value;
  589.  
  590.  node sxs,k;
  591.  BOOL found;
  592.  
  593.  jmp_buf  save_jmp;
  594.  unsigned save_valid=loop_jmp_valid;
  595.  unsigned save_flags=loop_jmp_flags;
  596.  
  597.  jmp_buf  save_go_jmp;
  598.  unsigned save_go_valid=go_jmp_valid;
  599.  
  600.  loop_jmp_valid=TRUE;
  601.  loop_jmp_flags=fl;
  602.  memcpy(save_jmp,loop_jmp,sizeof(jmp_buf));
  603.  
  604.  switch(setjmp(loop_jmp)){
  605.      case LONGJMP_LOOP:
  606.      memcpy(loop_jmp,save_jmp,sizeof(jmp_buf));
  607.      loop_jmp_valid=save_valid;
  608.      loop_jmp_flags=save_flags;
  609.      nout->node=loop_jmp_nout.node;
  610.      nout->type=loop_jmp_nout.type;
  611.  
  612.      memcpy(go_jmp,save_go_jmp,sizeof(jmp_buf));
  613.      go_jmp_valid=save_go_valid;
  614.  
  615.      return;
  616.  }
  617.  
  618.  if(IS_CONS(nin)){
  619.    parl=CONSLEFT(nin);
  620.    if(IS_CONS(parl)){
  621.      nin=CONSRIGHT(nin);
  622.      while(IS_CONS(parl)){
  623.        value=CONSLEFT(parl);
  624.        if(IS_CONS(value)){
  625.      name=CONSLEFT(value);
  626.      value=CONSRIGHT(value);
  627.      if(IS_CONS(value)){
  628.        value=CONSLEFT(value);
  629.      }
  630.      eval(value,nout,genv,lenv,EVAL_NORM);
  631.      value=calc_pointer(nout);
  632.        }else{
  633.      name=value;
  634.      value=NIL;
  635.        }
  636.        if(IS_NAME(name)&&HAS_NAME(name))
  637.      internal_update_environment(name,value,&new_genv,&new_lenv);
  638.        else
  639.      error(E_BADARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&name);
  640.        parl=CONSRIGHT(parl);
  641.      }
  642.    }
  643.    go_jmp_valid=TRUE;
  644.    memcpy(save_go_jmp,go_jmp,sizeof(jmp_buf));
  645.  
  646.    k=node_getlastlock();
  647.  
  648.    switch(setjmp(go_jmp)){
  649.      case LONGJMP_GO:
  650.      /* Cerca le sxs con go_jmp_label */
  651.      sxs=nin;
  652.      found=FALSE;
  653.      while(IS_CONS(sxs) && !found){
  654.        found=(CONSLEFT(sxs)==go_jmp_label);
  655.        sxs=CONSRIGHT(sxs);
  656.      }
  657.      if(!found)
  658.        error(E_BADLABEL,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&go_jmp_label);
  659.      break;
  660.      default:
  661.      sxs=nin;
  662.    }
  663.    node_signal(k);
  664.    nout->node=NIL;
  665.    nout->type=P_ALLNODE;
  666.    while(IS_CONS(sxs)){
  667.      /* non valuta i nomi dato che sono delle label */
  668.      if(!IS_NAME(CONSLEFT(sxs)))
  669.        eval(CONSLEFT(sxs),nout,new_genv,new_lenv,EVAL_NORM);
  670.      sxs=CONSRIGHT(sxs);
  671.    }
  672.    memcpy(go_jmp,save_go_jmp,sizeof(jmp_buf));
  673.    go_jmp_valid=save_go_valid;
  674.    return;
  675.  }
  676.  error(E_FEWARGS,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&nin);
  677. }
  678.  
  679.  
  680. void lf_go LF_PARAMS
  681. {
  682.  if(go_jmp_valid){
  683.    if(IS_CONS(nin)){
  684.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  685.      go_jmp_label=nout->node;
  686.      if(IS_NAME(go_jmp_label)){
  687.        longjmp(go_jmp,LONGJMP_GO);
  688.      }
  689.      go_jmp_label=calc_pointer(nout);
  690.      if(IS_NAME(go_jmp_label)){
  691.        longjmp(go_jmp,LONGJMP_GO);
  692.      }
  693.      error(E_BADLABEL,ERR_MERROR|ERR_TBLVL|ERR_PNODE,&go_jmp_label);
  694.    }
  695.  }
  696.  error(E_BADGO,ERR_MERROR|ERR_TBLVL|ERR_PVOID,NULL);
  697. }
  698.